home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / lib / perl5 / Getopt / Long.pm next >
Text File  |  1995-07-02  |  15KB  |  514 lines
  1. package Getopt::Long;
  2. require 5.000;
  3. require Exporter;
  4.  
  5. @ISA = qw(Exporter);
  6. @EXPORT = qw(GetOptions);
  7.  
  8.  
  9. # newgetopt.pl -- new options parsing
  10.  
  11. # SCCS Status     : @(#)@ newgetopt.pl    1.14
  12. # Author          : Johan Vromans
  13. # Created On      : Tue Sep 11 15:00:12 1990
  14. # Last Modified By: Johan Vromans
  15. # Last Modified On: Sat Feb 12 18:24:02 1994
  16. # Update Count    : 138
  17. # Status          : Okay
  18.  
  19. ################ Introduction ################
  20. #
  21. # This package implements an extended getopt function. This function adheres
  22. # to the new syntax (long option names, no bundling).
  23. # It tries to implement the better functionality of traditional, GNU and
  24. # POSIX getopt functions.
  25. # 
  26. # This program is Copyright 1990,1994 by Johan Vromans.
  27. # This program is free software; you can redistribute it and/or
  28. # modify it under the terms of the GNU General Public License
  29. # as published by the Free Software Foundation; either version 2
  30. # of the License, or (at your option) any later version.
  31. # 
  32. # This program is distributed in the hope that it will be useful,
  33. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  34. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  35. # GNU General Public License for more details.
  36. # 
  37. # If you do not have a copy of the GNU General Public License write to
  38. # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
  39. # MA 02139, USA.
  40.  
  41. ################ Description ################
  42. #
  43. # Usage:
  44. # 
  45. #    require "newgetopt.pl";
  46. #    ...change configuration values, if needed...
  47. #    $result = &NGetOpt (...option-descriptions...);
  48. # 
  49. # Each description should designate a valid perl identifier, optionally
  50. # followed by an argument specifier.
  51. # 
  52. # Values for argument specifiers are:
  53. # 
  54. #   <none>   option does not take an argument
  55. #   !        option does not take an argument and may be negated
  56. #   =s :s    option takes a mandatory (=) or optional (:) string argument
  57. #   =i :i    option takes a mandatory (=) or optional (:) integer argument
  58. #   =f :f    option takes a mandatory (=) or optional (:) real number argument
  59. # 
  60. # If option "name" is set, it will cause the perl variable $opt_name to
  61. # be set to the specified value. The calling program can use this
  62. # variable to detect whether the option has been set. Options that do
  63. # not take an argument will be set to 1 (one).
  64. # 
  65. # Options that take an optional argument will be defined, but set to ''
  66. # if no actual argument has been supplied.
  67. # 
  68. # If an "@" sign is appended to the argument specifier, the option is
  69. # treated as an array. Value(s) are not set, but pushed into array
  70. # @opt_name.
  71. # 
  72. # Options that do not take a value may have an "!" argument spacifier to
  73. # indicate that they may be negated. E.g. "foo!" will allow -foo (which
  74. # sets $opt_foo to 1) and -nofoo (which will set $opt_foo to 0).
  75. # 
  76. # The option name may actually be a list of option names, separated by
  77. # '|'s, e.g. "foo|bar|blech=s". In this example, options 'bar' and
  78. # 'blech' will set $opt_foo instead.
  79. # 
  80. # Option names may be abbreviated to uniqueness, depending on
  81. # configuration variable $autoabbrev.
  82. # 
  83. # Dashes in option names are allowed (e.g. pcc-struct-return) and will
  84. # be translated to underscores in the corresponding perl variable (e.g.
  85. # $opt_pcc_struct_return).  Note that a lone dash "-" is considered an
  86. # option, corresponding perl identifier is $opt_ .
  87. # 
  88. # A double dash "--" signals end of the options list.
  89. # 
  90. # If the first option of the list consists of non-alphanumeric
  91. # characters only, it is interpreted as a generic option starter.
  92. # Everything starting with one of the characters from the starter will
  93. # be considered an option.
  94. # 
  95. # The default values for the option starters are "-" (traditional), "--"
  96. # (POSIX) and "+" (GNU, being phased out).
  97. # 
  98. # Options that start with "--" may have an argument appended, separated
  99. # with an "=", e.g. "--foo=bar".
  100. # 
  101. # If configuration varaible $getopt_compat is set to a non-zero value,
  102. # options that start with "+" may also include their arguments,
  103. # e.g. "+foo=bar".
  104. # 
  105. # A return status of 0 (false) indicates that the function detected
  106. # one or more errors.
  107. #
  108. ################ Some examples ################
  109. # 
  110. # If option "one:i" (i.e. takes an optional integer argument), then
  111. # the following situations are handled:
  112. # 
  113. #    -one -two        -> $opt_one = '', -two is next option
  114. #    -one -2        -> $opt_one = -2
  115. # 
  116. # Also, assume "foo=s" and "bar:s" :
  117. # 
  118. #    -bar -xxx        -> $opt_bar = '', '-xxx' is next option
  119. #    -foo -bar        -> $opt_foo = '-bar'
  120. #    -foo --        -> $opt_foo = '--'
  121. # 
  122. # In GNU or POSIX format, option names and values can be combined:
  123. # 
  124. #    +foo=blech        -> $opt_foo = 'blech'
  125. #    --bar=        -> $opt_bar = ''
  126. #    --bar=--        -> $opt_bar = '--'
  127. # 
  128. ################ Configuration values ################
  129. # 
  130. #   $autoabbrev      Allow option names to be abbreviated to uniqueness.
  131. #                    Default is 1 unless environment variable
  132. #                    POSIXLY_CORRECT has been set.
  133. # 
  134. #   $getopt_compat   Allow '+' to start options.
  135. #                    Default is 1 unless environment variable
  136. #                    POSIXLY_CORRECT has been set.
  137. # 
  138. #   $option_start    Regexp with option starters.
  139. #                    Default is (--|-) if environment variable
  140. #                    POSIXLY_CORRECT has been set, (--|-|\+) otherwise.
  141. # 
  142. #   $order           Whether non-options are allowed to be mixed with
  143. #                    options.
  144. #                    Default is $REQUIRE_ORDER if environment variable
  145. #                    POSIXLY_CORRECT has been set, $PERMUTE otherwise.
  146. # 
  147. #   $ignorecase      Ignore case when matching options. Default is 1.
  148. # 
  149. #   $debug           Enable debugging output. Default is 0.
  150.  
  151. ################ History ################
  152. # 
  153. # 12-Feb-1994        Johan Vromans    
  154. #    Added "!" for negation.
  155. #    Released to the net.
  156. #
  157. # 26-Aug-1992        Johan Vromans    
  158. #    More POSIX/GNU compliance.
  159. #    Lone dash and double-dash are now independent of the option prefix
  160. #      that is used.
  161. #    Make errors in NGetOpt parameters fatal.
  162. #    Allow options to be mixed with arguments.
  163. #      Check $ENV{"POSIXLY_CORRECT"} to suppress this.
  164. #    Allow --foo=bar and +foo=bar (but not -foo=bar).
  165. #    Allow options to be abbreviated to minimum needed for uniqueness.
  166. #      (Controlled by configuration variable $autoabbrev.)
  167. #    Allow alias names for options (e.g. "foo|bar=s").
  168. #    Allow "-" in option names (e.g. --pcc-struct-return). Dashes are
  169. #      translated to "_" to form valid perl identifiers
  170. #      (e.g. $opt_pcc_struct_return). 
  171. #
  172. # 2-Jun-1992        Johan Vromans    
  173. #    Do not use //o to allow multiple NGetOpt calls with different delimeters.
  174. #    Prevent typeless option from using previous $array state.
  175. #    Prevent empty option from being eaten as a (negative) number.
  176. #
  177. # 25-May-1992        Johan Vromans    
  178. #    Add array options. "foo=s@" will return an array @opt_foo that
  179. #    contains all values that were supplied. E.g. "-foo one -foo -two" will
  180. #    return @opt_foo = ("one", "-two");
  181. #    Correct bug in handling options that allow for a argument when followed
  182. #    by another option.
  183. #
  184. # 4-May-1992        Johan Vromans    
  185. #    Add $ignorecase to match options in either case.
  186. #    Allow '' option.
  187. #
  188. # 19-Mar-1992        Johan Vromans    
  189. #    Allow require from packages.
  190. #    NGetOpt is now defined in the package that requires it.
  191. #    @ARGV and $opt_... are taken from the package that calls it.
  192. #    Use standard (?) option prefixes: -, -- and +.
  193. #
  194. # 20-Sep-1990        Johan Vromans    
  195. #    Set options w/o argument to 1.
  196. #    Correct the dreadful semicolon/require bug.
  197.  
  198. ################ Configuration Section ################
  199.  
  200. { 
  201.  
  202.     # Values for $order. See GNU getopt.c for details.
  203.     $REQUIRE_ORDER = 0;
  204.     $PERMUTE = 1;
  205.     $RETURN_IN_ORDER = 2;
  206.  
  207.     # Handle POSIX compliancy.
  208.     if ( defined $ENV{"POSIXLY_CORRECT"} ) {
  209.     $autoabbrev = 0;    # no automatic abbrev of options (???)
  210.     $getopt_compat = 0;    # disallow '+' to start options
  211.     $option_start = "(--|-)";
  212.     $order = $REQUIRE_ORDER;
  213.     }
  214.     else {
  215.     $autoabbrev = 1;    # automatic abbrev of options
  216.     $getopt_compat = 1;    # allow '+' to start options
  217.     $option_start = "(--|-|\\+)";
  218.     $order = $PERMUTE;
  219.     }
  220.  
  221.     # Other configurable settings.
  222.     $debug = 0;            # for debugging
  223.     $ignorecase = 1;        # ignore case when matching options
  224.     $argv_end = "--";        # don't change this!
  225. }
  226.  
  227. ################ Subroutines ################
  228.  
  229. sub GetOptions {
  230.  
  231.     @optionlist = @_;    #';
  232.  
  233.     local ($[) = 0;
  234.     local ($genprefix) = $option_start;
  235.     local ($argend) = $argv_end;
  236.     local ($error) = 0;
  237.     local ($opt, $optx, $arg, $type, $mand, %opctl);
  238.     local ($pkg) = (caller)[0];
  239.     local ($optarg);
  240.     local (%aliases);
  241.     local (@ret) = ();
  242.  
  243.     print STDERR "NGetOpt 1.14 -- called from $pkg\n" if $debug;
  244.  
  245.     # See if the first element of the optionlist contains option
  246.     # starter characters.
  247.     if ( $optionlist[0] =~ /^\W+$/ ) {
  248.     $genprefix = shift (@optionlist);
  249.     # Turn into regexp.
  250.     $genprefix =~ s/(\W)/\\$1/g;
  251.     $genprefix = "[" . $genprefix . "]";
  252.     }
  253.  
  254.     # Verify correctness of optionlist.
  255.     %opctl = ();
  256.     foreach $opt ( @optionlist ) {
  257.     $opt =~ tr/A-Z/a-z/ if $ignorecase;
  258.     if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
  259.         die ("Error in option spec: \"", $opt, "\"\n");
  260.         $error++;
  261.         next;
  262.     }
  263.     local ($o, $c, $a) = ($1, $2);
  264.  
  265.     if ( ! defined $o ) {
  266.         $opctl{''} = defined $c ? $c : '';
  267.     }
  268.     else {
  269.         # Handle alias names
  270.         foreach ( split (/\|/, $o)) {
  271.         if ( defined $c && $c eq '!' ) {
  272.             $opctl{"no$_"} = $c;
  273.             $c = '';
  274.         }
  275.         $opctl{$_} = defined $c ? $c : '';
  276.         if ( defined $a ) {
  277.             # Note alias.
  278.             $aliases{$_} = $a;
  279.         }
  280.         else {
  281.             # Set primary name.
  282.             $a = $_;
  283.         }
  284.         }
  285.     }
  286.     }
  287.     @opctl = sort(keys (%opctl)) if $autoabbrev;
  288.  
  289.     return 0 if $error;
  290.  
  291.     if ( $debug ) {
  292.     local ($arrow, $k, $v);
  293.     $arrow = "=> ";
  294.     while ( ($k,$v) = each(%opctl) ) {
  295.         print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
  296.         $arrow = "   ";
  297.     }
  298.     }
  299.  
  300.     # Process argument list
  301.  
  302.     while ( $#ARGV >= 0 ) {
  303.  
  304.     # >>> See also the continue block <<<
  305.  
  306.     #### Get next argument ####
  307.  
  308.     $opt = shift (@ARGV);
  309.     print STDERR ("=> option \"", $opt, "\"\n") if $debug;
  310.     $arg = undef;
  311.     $optarg = undef;
  312.     $array = 0;
  313.  
  314.     #### Determine what we have ####
  315.  
  316.     # Double dash is option list terminator.
  317.     if ( $opt eq $argend ) {
  318.         unshift (@ret, @ARGV) if $order == $PERMUTE;
  319.         return ($error == 0);
  320.     }
  321.     elsif ( $opt =~ /^$genprefix/ ) {
  322.         # Looks like an option.
  323.         $opt = $';        # option name (w/o prefix)
  324.         # If it is a long opt, it may include the value.
  325.         if (($+ eq "--" || ($getopt_compat && $+ eq "+")) && 
  326.         $opt =~ /^([^=]+)=/ ) {
  327.         $opt = $1;
  328.         $optarg = $';
  329.         print STDERR ("=> option \"", $opt, 
  330.                   "\", optarg = \"$optarg\"\n")
  331.             if $debug;
  332.         }
  333.  
  334.     }
  335.     # Not an option. Save it if we may permute...
  336.     elsif ( $order == $PERMUTE ) {
  337.         push (@ret, $opt);
  338.         next;
  339.     }
  340.     # ...otherwise, terminate.
  341.     else {
  342.         # Push back and exit.
  343.         unshift (@ARGV, $opt);
  344.         return ($error == 0);
  345.     }
  346.  
  347.     #### Look it up ###
  348.  
  349.     $opt =~ tr/A-Z/a-z/ if $ignorecase;
  350.  
  351.     local ($tryopt) = $opt;
  352.     if ( $autoabbrev ) {
  353.         local ($pat, @hits);
  354.  
  355.         # Turn option name into pattern.
  356.         ($pat = $opt) =~ s/(\W)/\\$1/g;
  357.         # Look up in option names.
  358.         @hits = grep (/^$pat/, @opctl);
  359.         print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
  360.               "out of ", 0+@opctl, "\n")
  361.         if $debug;
  362.  
  363.         # Check for ambiguous results.
  364.         unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
  365.         print STDERR ("Option ", $opt, " is ambiguous (",
  366.                   join(", ", @hits), ")\n");
  367.         $error++;
  368.         next;
  369.         }
  370.  
  371.         # Complete the option name, if appropriate.
  372.         if ( @hits == 1 && $hits[0] ne $opt ) {
  373.         $tryopt = $hits[0];
  374.         print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
  375.             if $debug;
  376.         }
  377.     }
  378.  
  379.     unless  ( defined ( $type = $opctl{$tryopt} ) ) {
  380.         print STDERR ("Unknown option: ", $opt, "\n");
  381.         $error++;
  382.         next;
  383.     }
  384.     $opt = $tryopt;
  385.     print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
  386.  
  387.     #### Determine argument status ####
  388.  
  389.     # If it is an option w/o argument, we're almost finished with it.
  390.     if ( $type eq '' || $type eq '!' ) {
  391.         if ( defined $optarg ) {
  392.         print STDERR ("Option ", $opt, " does not take an argument\n");
  393.         $error++;
  394.         }
  395.         elsif ( $type eq '' ) {
  396.         $arg = 1;        # supply explicit value
  397.         }
  398.         else {
  399.         substr ($opt, 0, 2) = ''; # strip NO prefix
  400.         $arg = 0;        # supply explicit value
  401.         }
  402.         next;
  403.     }
  404.  
  405.     # Get mandatory status and type info.
  406.     ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
  407.  
  408.     # Check if there is an option argument available.
  409.     if ( defined $optarg ? ($optarg eq '') : ($#ARGV < 0) ) {
  410.  
  411.         # Complain if this option needs an argument.
  412.         if ( $mand eq "=" ) {
  413.         print STDERR ("Option ", $opt, " requires an argument\n");
  414.         $error++;
  415.         }
  416.         if ( $mand eq ":" ) {
  417.         $arg = $type eq "s" ? '' : 0;
  418.         }
  419.         next;
  420.     }
  421.  
  422.     # Get (possibly optional) argument.
  423.     $arg = defined $optarg ? $optarg : shift (@ARGV);
  424.  
  425.     #### Check if the argument is valid for this option ####
  426.  
  427.     if ( $type eq "s" ) {    # string
  428.         # A mandatory string takes anything. 
  429.         next if $mand eq "=";
  430.  
  431.         # An optional string takes almost anything. 
  432.         next if defined $optarg;
  433.         next if $arg eq "-";
  434.  
  435.         # Check for option or option list terminator.
  436.         if ($arg eq $argend ||
  437.         $arg =~ /^$genprefix.+/) {
  438.         # Push back.
  439.         unshift (@ARGV, $arg);
  440.         # Supply empty value.
  441.         $arg = '';
  442.         }
  443.         next;
  444.     }
  445.  
  446.     if ( $type eq "n" || $type eq "i" ) { # numeric/integer
  447.         if ( $arg !~ /^-?[0-9]+$/ ) {
  448.         if ( defined $optarg || $mand eq "=" ) {
  449.             print STDERR ("Value \"", $arg, "\" invalid for option ",
  450.                   $opt, " (number expected)\n");
  451.             $error++;
  452.             undef $arg;    # don't assign it
  453.         }
  454.         else {
  455.             # Push back.
  456.             unshift (@ARGV, $arg);
  457.             # Supply default value.
  458.             $arg = 0;
  459.         }
  460.         }
  461.         next;
  462.     }
  463.  
  464.     if ( $type eq "f" ) { # fixed real number, int is also ok
  465.         if ( $arg !~ /^-?[0-9.]+$/ ) {
  466.         if ( defined $optarg || $mand eq "=" ) {
  467.             print STDERR ("Value \"", $arg, "\" invalid for option ",
  468.                   $opt, " (real number expected)\n");
  469.             $error++;
  470.             undef $arg;    # don't assign it
  471.         }
  472.         else {
  473.             # Push back.
  474.             unshift (@ARGV, $arg);
  475.             # Supply default value.
  476.             $arg = 0.0;
  477.         }
  478.         }
  479.         next;
  480.     }
  481.  
  482.     die ("NGetOpt internal error (Can't happen)\n");
  483.     }
  484.  
  485.     continue {
  486.     if ( defined $arg ) {
  487.         $opt = $aliases{$opt} if defined $aliases{$opt};
  488.         # Make sure a valid perl identifier results.
  489.         $opt =~ s/\W/_/g;
  490.         if ( $array ) {
  491.         print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
  492.             if $debug;
  493.             eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
  494.         }
  495.         else {
  496.         print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
  497.             if $debug;
  498.             eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
  499.         }
  500.     }
  501.     }
  502.  
  503.     if ( $order == $PERMUTE && @ret > 0 ) {
  504.     unshift (@ARGV, @ret);
  505.     }
  506.     return ($error == 0);
  507. }
  508.  
  509. ################ Package return ################
  510.  
  511. 1;
  512.  
  513.  
  514.